home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / ICON_UTL / STOP / STOPLITE.PAS < prev    next >
Pascal/Delphi Source File  |  1992-06-17  |  6KB  |  205 lines

  1. program StopLight;
  2.  
  3. {
  4.   Program:            STOPLITE.PAS
  5.   Version:            1.0
  6.   Creation Date:      June 18, 1992
  7.   Modification Date:  June 18, 1992
  8.   Operating System:   MS-DOS 3.x and Windows 3.x
  9.   Hardware Required:  Windows-capable computer system
  10.   Programming System: Turbo Pascal for Windows 1.0
  11.   Author:             Craig Boyd
  12.   Ownership:          Released to the public domain
  13.  
  14.  
  15.   About This Program
  16.  
  17.   Demonstration program showing how to use the wm_timer message
  18.   to animate an icon.
  19.  
  20.  
  21.   Update History
  22.  
  23.   update    ver   description (author)
  24.   -------   ---   -----------
  25.   9206.18   1.0   Released to public domain. (CSB)
  26.  
  27. }
  28.  
  29. uses
  30.   Strings,
  31.   WinTypes,
  32.   WinProcs,
  33.   WObjects,
  34.   Win31;               { <-- omit if you are using TPW under Windows 3.0 }
  35.  
  36. {$R STOPLITE.RES}
  37.  
  38. {-- Global Declarations -------------------------------------------------}
  39.  
  40. const
  41.   AppName    : pchar = 'Stoplight';
  42.   AppTitle   : pchar = 'Stoplight';
  43.   GreenLite  = 200;                                    { icon id numbers }
  44.   YellowLite = 201;
  45.   RedLite    = 202;
  46.  
  47. type
  48.   TStoplightApp = object(TApplication)
  49.     procedure InitMainWindow; virtual;
  50.   end;
  51.  
  52.   PMyWindow = ^TStoplightWindow;
  53.   TStoplightWindow = object(TWindow)
  54.     Counter : byte;              { counts passes thru the WMTimer method }
  55.     Red,                                                  { icon handles }
  56.     Yellow,
  57.     Green   : hicon;
  58.     destructor Done; virtual;
  59.     procedure SetupWindow; virtual;
  60.     function GetClassName : pchar; virtual;
  61.     procedure GetWindowClass(var WndClass : tWndClass); virtual;
  62.     procedure WMQueryOpen(var Msg : TMessage);
  63.       virtual wm_First + wm_QueryOpen;
  64.     procedure WMTimer(var Msg : TMessage);
  65.       virtual wm_First + wm_Timer;
  66.   end;
  67.  
  68. {-- TStoplightWindow Methods --------------------------------------------}
  69.  
  70. destructor TStoplightWindow.Done;
  71.   begin
  72.     {
  73.       Always kill the timer when you're done with it.
  74.     }
  75.     KillTimer(HWindow,1);
  76.     TWindow.Done;
  77.   end { TStoplightWindow.Done };
  78.  
  79. procedure TStoplightWindow.SetupWindow;
  80.   var
  81.     SysMenu : hMenu;
  82.   begin
  83.     TWindow.SetupWindow;
  84.     {
  85.       Remove unwanted system menu options.  Note: It seems that
  86.       removing the sc_Restore menu option is enough to prevent
  87.       an icon from being opened; the override of wm_QueryOpen
  88.       may be redundant.
  89.     }
  90.     SysMenu := GetSystemMenu(hWindow,false);
  91.     DeleteMenu(SysMenu,sc_Restore,mf_ByCommand);
  92.     DeleteMenu(SysMenu,sc_Size,mf_ByCommand);
  93.     DeleteMenu(SysMenu,sc_Minimize,mf_ByCommand);
  94.     DeleteMenu(SysMenu,sc_Maximize,mf_ByCommand);
  95.     {
  96.       Reset our timer pass counter.
  97.     }
  98.     Counter := 0;
  99.     {
  100.       Start a two-second timer.
  101.       Complain and exit if none are available.
  102.     }
  103.     if SetTimer(HWindow,1,2000,nil) = 0 then begin
  104.       MessageBeep(0);
  105.       MessageBox(HWindow,'No free timers','Error',mb_OK or mb_IconExclamation);
  106.       halt(1);
  107.     end;
  108.  end { TStoplightWindow.SetupWindow };
  109.  
  110. function TStoplightWindow.GetClassName;
  111.   begin
  112.     GetClassName := AppName;
  113.   end { TStoplightWindow.GetClassName };
  114.  
  115. procedure TStoplightWindow.GetWindowClass;
  116.   begin
  117.     TWindow.GetWindowClass(WndClass);
  118.     {
  119.       Load the three traffic light icon resources.
  120.     }
  121.     Red := LoadIcon(HInstance,pchar(RedLite));
  122.     Yellow := LoadIcon(HInstance,pchar(YellowLite));
  123.     Green := LoadIcon(HInstance,pchar(GreenLite));
  124.     {
  125.       We'll start with the green light.
  126.     }
  127.     WndClass.hIcon := Green;
  128.   end { TStoplightWindow.GetWindowClass };
  129.  
  130. procedure TStoplightWindow.WMQueryOpen;
  131. {
  132.   Override requests to open the window.
  133. }
  134.   begin
  135.     Msg.Result := 0;
  136.   end { TStoplightWindow.WMQueryOpen };
  137.  
  138. procedure TStoplightWindow.WMTimer;
  139. {
  140.   Here's where all the work is done.  This method handles the timer
  141.   messages, which are sent at two-second intervals.  We want the visible
  142.   icon to cycle from green to yellow to red, then start all over again.
  143.   We use a counter to determine which icon to display.  When this method
  144.   is called, it checks the value of the counter and responds as shown
  145.   in the following table...
  146.  
  147.   Value  Response
  148.   -----  --------
  149.     0    Load and display green light icon.
  150.     1    Do nothing.
  151.     2    Load and display yellow light icon.
  152.     3    Load and display red light icon.
  153.     4    Do nothing.
  154.     5    Reset the counter.
  155.  
  156.   In other words, we display the green light for 4 seconds, the yellow
  157.   light for 2 seconds, the red light for four seconds, then start all
  158.   over again.
  159.  
  160.   By adjusting the timer frequency (in TStoplightWindow.SetupWindow) and
  161.   the counter step values, you can simulate the traffic light cycle of
  162.   your favorite intersection!
  163. }
  164.   begin
  165.     inc(Counter);
  166.     if Counter > 4 then Counter := 0;
  167.     {
  168.       Update TStoplightWindow's icon handle, based on the counter value.
  169.     }
  170.     case Counter of
  171.       0 : SetClassWord(HWindow,gcw_HIcon,Green);
  172.       2 : SetClassWord(HWindow,gcw_HIcon,Yellow);
  173.       3 : SetClassWord(HWindow,gcw_HIcon,Red);
  174.     else
  175.       exit;
  176.     end;
  177.     {
  178.       Force the new icon to be displayed.
  179.     }
  180.     InvalidateRect(HWindow,nil,true);
  181.   end { TStoplightWindow.WMTimer };
  182.  
  183. {-- TStoplightApp Methods -----------------------------------------------}
  184.  
  185. procedure TStoplightApp.InitMainWindow;
  186.   begin
  187.     MainWindow := New(PMyWindow,Init(nil,AppTitle));
  188.   end { TStoplightApp.InitMainWindow };
  189.  
  190. {-- Main Program --------------------------------------------------------}
  191.  
  192. var
  193.   StoplightApp : TStoplightApp;
  194.  
  195. begin
  196.   {
  197.     We want our app to start out minimized.
  198.   }
  199.   CmdShow := sw_ShowMinimized;
  200.  
  201.   StoplightApp.Init(AppName);
  202.   StoplightApp.Run;
  203.   StoplightApp.Done;
  204. end.
  205.